home *** CD-ROM | disk | FTP | other *** search
/ Mac Easy 2010 May / Mac Life Ubuntu.iso / casper / filesystem.squashfs / usr / share / gnome-games / aisleriot / games / eagle_wing.scm < prev    next >
Encoding:
Text File  |  2009-04-14  |  10.7 KB  |  368 lines
  1. ; AisleRiot - eagle_wing.scm
  2. ; Copyright (C) 1998, 2003 Rosanna Yuen <rwsy@mit.edu>
  3. ;
  4. ; This game is free software; you can redistribute it and/or modify
  5. ; it under the terms of the GNU General Public License as published by
  6. ; the Free Software Foundation; either version 2, or (at your option)
  7. ; any later version.
  8. ;
  9. ; This program is distributed in the hope that it will be useful,
  10. ; but WITHOUT ANY WARRANTY; without even the implied warranty of
  11. ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  12. ; GNU General Public License for more details.
  13. ;
  14. ; You should have received a copy of the GNU General Public License
  15. ; along with this program; if not, write to the Free Software
  16. ; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307
  17. ; USA
  18.  
  19. (define BASE-VAL 0)
  20.  
  21. (define (new-game)
  22.   (initialize-playing-area)
  23.   (set-ace-low)
  24.   (make-standard-deck)
  25.   (shuffle-deck)
  26.  
  27.   (add-normal-slot DECK)
  28.   (add-normal-slot '())                 ;waste
  29.  
  30.   (add-blank-slot)
  31.   (add-normal-slot '())
  32.   (add-normal-slot '())
  33.   (add-normal-slot '())
  34.   (add-normal-slot '())
  35.  
  36.   (add-carriage-return-slot)
  37.   (set! VERTPOS (+ VERTPOS 0.2))
  38.   (add-extended-slot '() down)          ;tableau (slot 6)
  39.   (set! VERTPOS (- VERTPOS 0.1))
  40.   (add-extended-slot '() down)          ;tableau (slot 7)
  41.   (set! VERTPOS (- VERTPOS 0.1))
  42.   (add-extended-slot '() down)          ;tableau (slot 8)
  43.   (set! VERTPOS (+ VERTPOS 0.1))
  44.   (add-extended-slot '() down)          ;tableau (slot 9)
  45.   (set! VERTPOS (+ VERTPOS 0.25))
  46.   (add-normal-slot '())                 ;reserve (slot 10)
  47.   (set! VERTPOS (- VERTPOS 0.25))
  48.   (add-extended-slot '() down)          ;tableau (slot 11)
  49.   (set! VERTPOS (- VERTPOS 0.1))
  50.   (add-extended-slot '() down)          ;tableau (slot 12)
  51.   (set! VERTPOS (+ VERTPOS 0.1))
  52.   (add-extended-slot '() down)          ;tableau (slot 13)
  53.   (set! VERTPOS (+ VERTPOS 0.1))
  54.   (add-extended-slot '() down)          ;tableau (slot 14)
  55.  
  56.   (deal-cards-face-up 0 '(10))
  57.   (deal-cards 0 '(10 10 10 10 10 10 10 10 10 10 10 10 6 7 8 9 11 12 13 14 2))
  58.  
  59.   (flip-top-card 2)
  60.   (flip-top-card 6)
  61.   (flip-top-card 7)
  62.   (flip-top-card 8)
  63.   (flip-top-card 9)
  64.   (flip-top-card 11)
  65.   (flip-top-card 12)
  66.   (flip-top-card 13)
  67.   (flip-top-card 14)
  68.  
  69.   (add-to-score! 1)
  70.   (set! BASE-VAL (get-value (get-top-card 2)))
  71.  
  72.   (give-status-message)
  73.  
  74.   (list 9 3))
  75.  
  76. (define (give-status-message)
  77.   (set-statusbar-message (string-append (get-stock-no-string)
  78.                     "   "
  79.                     (get-reserve-no-string)
  80.                     "   "
  81.                     (get-base-string)
  82.                     "   "
  83.                     (get-redeals-string))))
  84.  
  85. (define (get-stock-no-string)
  86.   (string-append (_"Stock left:") " "
  87.          (number->string (length (get-cards 0)))))
  88.  
  89. (define (get-reserve-no-string)
  90.   (string-append (_"Reserve left:") " "
  91.          (number->string (length (get-cards 10)))))
  92.  
  93. (define (get-base-string)
  94.   (cond ((and (> BASE-VAL 1)
  95.           (< BASE-VAL 11))
  96.      (string-append (_"Base Card: ") (number->string BASE-VAL)))
  97.     ((= BASE-VAL 1)
  98.      (_"Base Card: Ace"))
  99.     ((= BASE-VAL 11)
  100.      (_"Base Card: Jack"))
  101.     ((= BASE-VAL 12)
  102.      (_"Base Card: Queen"))
  103.     ((= BASE-VAL 13)
  104.      (_"Base Card: King"))
  105.     (#t "")))
  106.  
  107. (define (get-redeals-string)
  108.   (string-append (_"Redeals left:") " "
  109.          (number->string (- 2 FLIP-COUNTER))))
  110.  
  111. (define (button-pressed slot-id card-list)
  112.   (and card-list
  113.        (not (member slot-id '(2 3 4 5)))
  114.        (is-visible? (car card-list))))
  115.  
  116. (define (complete-transaction start-slot card-list end-slot)
  117.   (if (member end-slot '(2 3 4 5))
  118.       (add-to-score! (length card-list)))
  119.   (move-n-cards! start-slot end-slot card-list)
  120.   (if (and (not (= start-slot 1))
  121.        (empty-slot? start-slot)
  122.        (not (empty-slot? 10)))
  123.       (deal-cards-face-up 10 (cons start-slot '())))
  124.   (give-status-message))
  125.  
  126. (define (droppable? start-slot card-list end-slot)
  127.   (and (not (= start-slot end-slot))
  128.        (or (and (member end-slot '(2 3 4 5))
  129.         (if (empty-slot? end-slot)
  130.             (= (get-value (car card-list)) BASE-VAL)
  131.             (and (eq? (get-suit (car card-list))
  132.                   (get-suit (get-top-card end-slot)))
  133.              (or (= (get-value (car card-list))
  134.                 (+ (get-value (get-top-card end-slot)) 1))
  135.                  (and (= (get-value (car card-list)) ace)
  136.                   (= (get-value (get-top-card end-slot)) 
  137.                      king))))))
  138.        (and (member end-slot '(6 7 8 9 11 12 13 14))
  139.         (= (length card-list) 1)
  140.         (or (empty-slot? end-slot)
  141.             (and (< (length (get-cards end-slot)) 3)
  142.              (eq? (get-suit (car card-list))
  143.                   (get-suit (get-top-card end-slot)))
  144.              (or (= (get-value (car card-list))
  145.                 (- (get-value (get-top-card end-slot)) 1))
  146.                  (and (= (get-value (car card-list)) king)
  147.                   (= (get-value (get-top-card end-slot)) 
  148.                      ace)))))))))
  149.  
  150. (define (button-released start-slot card-list end-slot)
  151.   (and (droppable? start-slot card-list end-slot)
  152.        (complete-transaction start-slot (reverse card-list) end-slot)))
  153.  
  154. (define (dealable?)
  155.   (flippable? 0 2))
  156.  
  157. (define (do-deal-next-cards)
  158.   (begin
  159.     (flip-stock 0 1 2)
  160.     (give-status-message)))
  161.  
  162. (define (button-clicked slot-id)
  163.   (if (= slot-id 0)
  164.       (do-deal-next-cards)
  165.       #f))
  166.  
  167. (define (button-double-clicked slot)
  168.   (if (and (not (empty-slot? slot))
  169.        (is-visible? (get-top-card slot))
  170.        (or (= slot 1)
  171.            (and (> slot 5)
  172.             (< slot 10))
  173.            (and (> slot 10))))
  174.       (cond ((and (= BASE-VAL (get-value (get-top-card slot))))
  175.          (cond ((empty-slot? 2)
  176.             (begin
  177.               (deal-cards slot '(2))
  178.               (add-to-score! 1)))
  179.            ((empty-slot? 3)
  180.             (begin
  181.               (deal-cards slot '(3))
  182.               (add-to-score! 1)))
  183.            ((empty-slot? 4)
  184.             (begin
  185.               (deal-cards slot '(4))
  186.               (add-to-score! 1)))
  187.            (#t
  188.             (begin 
  189.               (deal-cards slot '(5))
  190.               (add-to-score! 1)))))
  191.         ((and (not (empty-slot? 2))
  192.           (= (get-suit (get-top-card slot))
  193.              (get-suit (get-top-card 2))))
  194.          (if (or (and (= (get-value (get-top-card slot)) ace)
  195.               (= (get-value (get-top-card 2)) king))
  196.              (= (get-value (get-top-card slot))
  197.             (+ 1 (get-value (get-top-card 2)))))
  198.          (begin
  199.            (deal-cards slot '(2))
  200.            (add-to-score! 1))
  201.          #f))
  202.         ((and (not (empty-slot? 3))
  203.           (= (get-suit (get-top-card slot))
  204.              (get-suit (get-top-card 3))))
  205.          (if (or (and (= (get-value (get-top-card slot)) ace)
  206.               (= (get-value (get-top-card 3)) king))
  207.              (= (get-value (get-top-card slot))
  208.             (+ 1 (get-value (get-top-card 3)))))
  209.          (begin
  210.            (deal-cards slot '(3))
  211.            (add-to-score! 1))
  212.          #f))
  213.         ((and (not (empty-slot? 4))
  214.           (= (get-suit (get-top-card slot))
  215.              (get-suit (get-top-card 4))))
  216.          (if (or (and (= (get-value (get-top-card slot)) ace)
  217.               (= (get-value (get-top-card 4)) king))
  218.              (= (get-value (get-top-card slot))
  219.             (+ 1 (get-value (get-top-card 4)))))
  220.          (begin
  221.            (deal-cards slot '(4))
  222.            (add-to-score! 1))
  223.          #f))
  224.         ((and (not (empty-slot? 5))
  225.           (= (get-suit (get-top-card slot))
  226.              (get-suit (get-top-card 5))))
  227.          (if (or (and (= (get-value (get-top-card slot)) ace)
  228.               (= (get-value (get-top-card 5)) king))
  229.              (= (get-value (get-top-card slot))
  230.             (+ 1 (get-value (get-top-card 5)))))
  231.          (begin
  232.            (deal-cards slot '(5))
  233.            (add-to-score! 1))
  234.          #f))
  235.         (#t #f))
  236.       #f)
  237.   (if (and (> slot 5)
  238.        (not (= slot 10))
  239.        (empty-slot? slot)
  240.        (not (empty-slot? 10)))
  241.       (deal-cards-face-up 10 (cons slot '()))))
  242.  
  243. (define (game-over)
  244.   (and (not (game-won))
  245.        (get-hint)))
  246.  
  247. (define (game-won)
  248.   (and (empty-slot? 0)
  249.        (empty-slot? 1)
  250.        (empty-slot? 6)
  251.        (empty-slot? 7)
  252.        (empty-slot? 8)
  253.        (empty-slot? 9)
  254.        (empty-slot? 10)
  255.        (empty-slot? 11)
  256.        (empty-slot? 12)
  257.        (empty-slot? 13)
  258.        (empty-slot? 14)))
  259.  
  260. (define (check-a-foundation slot1 slot2)
  261.   (and (not (empty-slot? slot2))
  262.        (= (get-suit (get-top-card slot1))
  263.       (get-suit (get-top-card slot2)))
  264.        (or (= (get-value (get-top-card slot1))
  265.           (+ 1 (get-value (get-top-card slot2))))
  266.        (and (= (get-value (get-top-card slot1)) ace)
  267.         (= (get-value (get-top-card slot2)) king)))))
  268.  
  269. (define (check-to-foundation slot)
  270.   (if (and (not (empty-slot? slot))
  271.        (is-visible? (get-top-card slot)))
  272.       (cond ((= (get-value (get-top-card slot)) BASE-VAL)
  273.          (list 0 (format (_"Move ~a to an empty foundation") (get-name (get-top-card slot)))))
  274.         ((check-a-foundation slot 2)
  275.          (list 1 
  276.            (get-name (get-top-card slot)) 
  277.            (get-name (get-top-card 2))))
  278.         ((check-a-foundation slot 3)
  279.          (list 1 
  280.            (get-name (get-top-card slot)) 
  281.            (get-name (get-top-card 3))))
  282.         ((check-a-foundation slot 4)
  283.          (list 1 
  284.            (get-name (get-top-card slot)) 
  285.            (get-name (get-top-card 4))))
  286.         ((check-a-foundation slot 5)
  287.          (list 1 
  288.            (get-name (get-top-card slot)) 
  289.            (get-name (get-top-card 5))))
  290.         ((= slot 1)
  291.          (check-to-foundation 6))
  292.         ((< slot 14)
  293.          (check-to-foundation (+ 1 slot)))
  294.         (#t #f))
  295.       (if (= slot 1)
  296.       (check-to-foundation 6)
  297.       (if (< slot 14)
  298.           (check-to-foundation (+ 1 slot))
  299.           #f))))
  300.  
  301. (define (check-empty-slot slot)
  302.   (if (and (empty-slot? slot)
  303.        (not (= slot 10)))
  304.       (if (empty-slot? 1)
  305.       #f
  306.       (list 2 (get-name (get-top-card 1)) (_"an empty slot on tableau")))
  307.       (if (< slot 14)
  308.       (check-empty-slot (+ 1 slot))
  309.       #f)))
  310.  
  311. (define (check-to-tableau slot card check-slot)
  312.   (if (and (not (= slot check-slot))
  313.        (not (= check-slot 10))
  314.        (not (empty-slot? check-slot))
  315.        (< (length (get-cards check-slot)) 3)
  316.        (= (get-suit card)
  317.           (get-suit (get-top-card check-slot)))
  318.        (or (= (+ 1 (get-value card))
  319.           (get-value (get-top-card check-slot)))
  320.            (and (= (get-value card) king)
  321.             (= (get-value (get-top-card check-slot)) ace))))
  322.       (list 1 (get-name card) (get-name (get-top-card check-slot)))
  323.       (if (< check-slot 14)
  324.       (check-to-tableau slot card (+ 1 check-slot))
  325.       #f)))
  326.  
  327. (define (check-tableau slot)
  328.   (if (and (not (empty-slot? slot))
  329.        (or (= slot 1)
  330.            (and (> slot 5)
  331.             (is-visible? (get-top-card slot))
  332.             (= 1 (length (get-cards slot))))))
  333.       (check-to-tableau slot (get-top-card slot) 6)
  334.       #f))
  335.  
  336. (define (dealable?)
  337.   (if (not (empty-slot? 0))
  338.       (list 0 (_"Deal a card"))
  339.       (if (and (not (empty-slot? 1))
  340.            (< FLIP-COUNTER 2))
  341.       (list 0 (_"Move waste back to stock"))
  342.       #f)))
  343.  
  344. (define (get-hint)
  345.   (or (check-to-foundation 1)
  346.       (check-empty-slot 6)
  347.       (check-tableau 1)
  348.       (check-tableau 6)
  349.       (check-tableau 7)
  350.       (check-tableau 8)
  351.       (check-tableau 9)
  352.       (check-tableau 10)
  353.       (check-tableau 11)
  354.       (check-tableau 12)
  355.       (check-tableau 13)
  356.       (check-tableau 14)
  357.       (dealable?)))
  358.  
  359. (define (get-options) #f)
  360.  
  361. (define (apply-options options) #f)
  362.  
  363. (define (timeout) #f)
  364.  
  365. (set-features droppable-feature dealable-feature)
  366.  
  367. (set-lambda new-game button-pressed button-released button-clicked button-double-clicked game-over game-won get-hint get-options apply-options timeout droppable? dealable?)
  368.